##########################################
# paulv@bikkel.org / paulv@dds.nl        #
# Urlmap mass virtual hosting plugin     #
#                                        #   
#                                        
##########################################

package Perlbal::Plugin::Urlmap;

use strict;
use warnings;
no  warnings qw(deprecated);
use CDB_File;

our %config;  # service_name => $svc

my $serverid   ='DDSweb';
my $catref;
my %cat; 


# called when we're being added to a service
sub register {

    my ($class, $svc) = @_;
    unless ($svc && $svc->{role} eq "selector" ) {
        die "You can't load the urlmap plugin on a service that is not a selector.\n";
    }

    $svc->selector(\&urlmap_selector);
    $svc->{extra_config}->{_urlmap} ||= {};
    $config{"$svc"} = $svc;

    $svc->register_hook('Urlmap', 'start_proxy_request', sub {
        my Perlbal::BackendHTTP $obj = shift;
        my Perlbal::HTTPHeaders $hds = $obj->{req_headers};
        my Perlbal::Service $svc = $obj->{service};
        return 0 unless defined $hds && defined $svc;

        return 1;
    });

 
}

# called when we're no longer active on a service
sub unregister {
    my ($class, $svc) = @_;

    # clean up time
    $svc->unregister_hooks('Urlmap');
    delete $config{"$svc"};

    return 1;
}



# when "LOAD" directive loads us up
sub load {
    my $class = shift;

    Perlbal::register_global_hook('manage_command.urlmap', sub {
        my $mc = shift->parse(qr/^urlmap ([\S\.]+) ?= ?(.+)$/ ,
		"usage: URLMAP <action> = <dest_service>");
        my ($action, $target) = $mc->args;

	my $ss;
        unless ($ss = Perlbal->service( $mc->{ctx}{last_created} ) ) {
            return $mc->err("omitted service name not implied from context");
        }

        if ( $ss && ( $ss->{role} ne 'reverse_proxy' && $ss->{role} ne 'selector') ) { 
        	return $mc->err("Service '$target' is not a reverse_proxy or selector .. its :'" . $ss->{role} . "'")
	}

        $ss->{extra_config}->{_urlmap} ||= {};
        $ss->{extra_config}->{_urlmap}{$action} = $target;

        return $mc->ok;
    });

    Perlbal::register_global_hook('manage_command.urlmapcdb', sub {
        my $mc = shift->parse(qr/^urlmapcdb\s*=\s*([\S\/\.]+)$/ ,
		"usage: URLMAPCDB = <urlmapcdbfile>");
        my ($urlmapcdb) = $mc->args;

        return $mc->err("invalid urlmap file : $urlmapcdb") unless -f "$urlmapcdb";

	if ( %cat ) { 
        	#return $mc->err("urlmap file already defined") 
		#untie %cat;
	} else { 
		%cat=();
		return $mc->err("could not read urlmap file : '$urlmapcdb'")  unless $catref = tie(%cat,'CDB_File', $urlmapcdb);
	}	

        return $mc->ok;


    });

    Perlbal::register_global_hook('manage_command.urlmaprewrite', sub {
        my $mc = shift->parse(qr/^urlmaprewrite\s*=\s*([\S]+)\s*$/ ,
		"usage: URLMAPREWRITE = [expandtildetofirstchar]");
        my ($urlmaprewrite) = $mc->args;

	my $ss;
        unless ($ss = Perlbal->service( $mc->{ctx}{last_created} ) ) {
            return $mc->err("omitted service name not implied from context");
        }

        $ss->{extra_config}->{_urlmap} ||= {};
        $ss->{extra_config}->{_urlmap}{'rewrite'} = $urlmaprewrite;

        return $mc->err("invalid regex: $urlmaprewrite") unless $urlmaprewrite;

        return $mc->ok;


    });

    return 1;
}

# unload our global commands, clear our service object
sub unload {
    my $class = shift;

    undef $catref;
    untie %cat;
    Perlbal::unregister_global_hook('manage_command.urlmap');
    unregister($class, $_) foreach (values %config);
    return 1;
}



# call back from Service via ClientHTTPBase's event_read calling service->select_new_service(Perlbal::ClientHTTPBase)
sub urlmap_selector {

    my Perlbal::ClientHTTPBase $cb = shift;
    my $req = $cb->{req_headers};

    return $cb->_simple_response(500, "Invalid request (no reqheaders)")  unless $req;
    return $cb->_simple_response(500, "Invalid request (no URI)")         unless my $uri   = $req->request_uri;
    return $cb->_simple_response(500, "Invalid request (no client ip)")   unless my $srcip = $cb->peer_ip_string;
    return $cb->_simple_response(404, "Not Found (no vhost)")             unless my $vhost = $req->header("Host");

    my $referer = $req->header("Referer");

    # we ONY want a (lowercase) vhost, no port numbers.
    $vhost =~ s/:\d+$//;
    $vhost = lc($vhost);


    my $oldpos=0;
    my @fields;
    my %result = ();
    my @mappings;  

    # Ok, here we go.. we begin with the virtualhost as searchquery, because if it's
    # not in there we're done anyway 
    my $x = $catref->multi_get($vhost);

    if(not defined( @$x) ) {  # Notting found.. 
        $cb->_simple_response(404, "Not Found");
        return 1;
    } else { 
    	@mappings = @$x; 
    }

    # if the request is for a dynamic url then we'll need to send it to the 
    # dynamic service if it's there .. we do this by creating dynamic mappings on the fly
    if ( $uri =~ /\/$/ or $uri =~ m/\/\?/ ) { 
        my @appmappings = @mappings;
	foreach ( @appmappings )  { 
		if ( m/(\S+,\/)\S+?,(\S*?,\S+,file,application\/.*)/ ) {
			push ( @mappings,"$1$2" ); 
			push ( @mappings,"$1.*\?.*,$2" ); 
		}
	}
    }


    foreach( @mappings ) {
	my ( $u_vhost,$u_path_mask,$u_match_ip_mask,$u_new_path,$u_methode,$u_mime_type,$u_access_class) = split(/\,/);

        next if( $u_match_ip_mask and $srcip and not $srcip =~ /$u_match_ip_mask/ );    # remote ip inside a rulematch ?

        $_ = $uri;

        # The request must match the rule 
        next unless ( /$u_path_mask/g );

        # If the match is worse, skip
        next unless $oldpos <= pos();

        # matches are equal, make decission
        if( $oldpos == pos() ) {
            # check for mimetype set or method blocked
            next unless $u_mime_type || ($u_methode eq "blocked") ;
        }

        # Take the old possition and fields
        $oldpos = pos();                       
        $result{'vhosts'}    = $u_vhost;
        $result{'path_mask'} = $u_path_mask;
        $result{'ipmask'}    = $u_match_ip_mask;
        $result{'new_path'}  = $u_new_path;
        $result{'method'}    = $u_methode;
        $result{'type'}      = '';
        $result{'mimetype'}  = '';
        if( $u_methode   ){ $result{'type'} = $u_methode   }
        if( $u_mime_type ){ $result{'mimetype'} = $u_mime_type }

	}

    # reset the regex match-tracker!
    $oldpos = 0;

    # mime_type and access_class can be empty..
    if( not exists($result{'method'}) ) {  # Notting found.. 

        $cb->_simple_response(404, "Not Found (the website is not configured to run on this system)");
        return 1;

    } elsif( $result{'method'} eq 'blocked' ) { 

        $cb->write( "HTTP/1.1 302 Temporary Redirect
Server: $serverid
Location: $result{'new_path'}?host=${vhost}&uri=$result{'new_path'}$result{'type'}}&refer=$referer&remoteip=$srcip
Content-Type: text/html

<!DOCTYPE HTML PUBLIC \"-//IETF//DTD HTML 2.0//EN\">
<HTML><HEAD>
<TITLE>302 Found</TITLE>
</HEAD><BODY>
<H1>Found</H1>
<p>Please see <a href=\"$result{'new_path'}?host=${vhost}&uri=$uri&refer=$referer&remoteip=$srcip\"> $result{'new_path'}?host=${vhost}&uri=$uri&refer=$referer&remoteip=$srcip </a></p>
</BODY></HTML>

0

");
        return 1;

    } elsif( $result{'method'} eq 'redirect' ) { 

        $cb->write( "HTTP/1.0 302 Temporary Redirect
Content-Type: text/html
Location: $result{'new_path'}
Server: $serverid

<!DOCTYPE HTML PUBLIC \"-//IETF//DTD HTML 2.0//EN\">
<HTML><HEAD>
<TITLE>302 Found</TITLE>
</HEAD><BODY>
<H1>Found</H1>
<p>Please see <a href=\"$result{'new_path'}\"> $result{'new_path'} </a></p>
</BODY></HTML>

0

");
        return 1;

    } elsif( $result{'method'} eq 'redirect-uri' ) { 

        $cb->write( "HTTP/1.0 302 Temporary Redirect
Location: $result{'new_path'}$uri
Content-Type: text/html
Server: $serverid

<!DOCTYPE HTML PUBLIC \"-//IETF//DTD HTML 2.0//EN\">
<HTML><HEAD>
<TITLE>302 Found</TITLE>
</HEAD><BODY>
<H1>Found</H1>
<p>Please see <a href=\"$result{'new_path'}$uri\"> $result{'new_path'}$uri </a></p>
</BODY></HTML>

0

");
        return 1;

    } elsif( $result{'method'} eq 'frame' ) { 

        $cb->write( "HTTP/1.0 200 OK
Server: $serverid
Content-Type: text/html

<!DOCTYPE HTML PUBLIC \"-//IETF//DTD HTML 2.0//EN\">
<html><head>
<title>$vhost</title>
</head>
 <frameset rows='100%, *' frameborder='no' framespacing=0 border=0>
  <frame src='$result{'new_path'}' name='mainwindow' frameborder=0 framespacing=0 marginheight=0 marginwidth=0></frame>
 </frameset>
 <noframes>
  <center> 
   <h2> Your browser does not support frames. Use links (not Lynx)!  </h2>
   <br/><br/> Go <a href='$result{'new_path'}'>Here</a> to enter the site.
  </center>
 </noframes>
</html>

0

");
        return 1;

    } elsif( $result{'method'} eq 'frame-uri' ) { 
        $cb->write( "HTTP/1.0 200 OK
Server: $serverid
Content-Type: text/html
 
<!DOCTYPE HTML PUBLIC \"-//IETF//DTD HTML 2.0//EN\">
<html><head>
<title>$vhost</title>
</head>
 <frameset rows='100%, *' frameborder='no' framespacing=0 border=0>
  <frame src='$result{'new_path'}$uri' name='mainwindow' frameborder=0 framespacing=0 marginheight=0 marginwidth=0></frame>
 </frameset>
 <noframes>
  <center> 
   <h2> Your browser does not support frames. Use links (not Lynx)!  </h2>
   <br/><br/> Go <a href='$result{'new_path'}$uri'>Here</a> to enter the site.
  </center>
 </noframes>
</html>

0

");
        return 1;

    } else {

 	our $svc;
        my $maps = $cb->{service}{extra_config}{_urlmap} ||= {};

	$uri = $result{'new_path'} . $uri; 
	
        my $urlmaprewrite = $cb->{service}{extra_config}{_urlmap}{'rewrite'};

 	if( $result{'type'} eq 'file' && $urlmaprewrite eq 'expandtildetofirstchar' ) {
        	$uri =~ s|~(.{1})(.*)|/$1/$1$2| ; 
	}
	
	# force through dynamic service, since we don't know how to handle / .. 
 	if( $result{'type'} eq 'file' && $uri eq '/' && grep( { m/application/ } @$x ) ) { # we have a / uri, and a application
		$svc = Perlbal->service( $maps->{$result{'mimetype'}} );

 	} elsif ( $result{'type'} eq 'file' && $result{'mimetype'} eq '' ) { # static content and no app-type forced
		$svc = Perlbal->service( $maps->{$result{'type'}} );

	} else { 
		$svc = Perlbal->service( $maps->{$result{'mimetype'}} );
	} 

	if ($svc) {
		$req->set_request_uri($uri);
        	$svc->adopt_base_client($cb);
	} else {
		$cb->_simple_response(500, "internal server error: $result{'mimetype'} is not a defined service");
	}	
        return 1;

    }

}


1;

__END__

=head1 NAME

Perlbal::Plugin::Urlmap -  plugin for mass virtual hosting 

=head1 VERSION

This documentation refers to C<Perlbal::Plugin::Urlmap> 

=head1 DESCRIPTION

Urlmap is a perlbal plugin that allows you to do mass virtual hosting with perlbal using a cdb rules file.

=head1 CONFIGURING PERLBAL

To configure your Perlbal installation to use Urlmap you'll need to C<LOAD> the plugin then add a service parameter to a C<web_server> service to activate it.

Example C<perlbal.conf>:

LOAD Urlmap
URLMAPCDB  = /etc/perlbal/urlmap.cdb

CREATE SERVICE web_proxy
  SET role            = selector
  SET listen          = 0.0.0.0:80

  URLMAP   file                     = static
  URLMAP   application/fotoalbum    = fotoalbum
  URLMAP   application/webdav       = webdav
  URLMAP   application/php          = dynamic_php4
  URLMAP   application/php5         = dynamic_php5
  URLMAP   application/python_user  = dynamic_python6_peruser
  URLMAP   application/perl_user    = dynamic_perl5_peruser
ENABLE web_proxy

the target can be any service. It can be a webserver, 
reverse_proxy service, or for example a Perlbal cgilike  
service. 


=head1 INTERNAL TARGETS

The following internal targets are build in : 

* blocked  

target will redirect the request to the specified blocked url, with the vhost / ip / etc as parameters

* redirect

target will do a HTTP 302 redirect to the specfied url

* redirect-uri

target will do a HTTP 302 redirect to the specfied url, but with the original request appended. 
So a GET /foo.gif with a redirect-uri rule of http://www.foo.bar/test will become a redirect to :
http://www.foo.bar/test/foo.gif 

* frame

target will give back a zero height frame to the specfied url 

* frame-uri

target will give back a zero height frame to the specfied url, but with the original request appended.
So a GET /foo.gif with a frame-uri rule of http://www.foo.bar/test will become a redirect to :
http://www.foo.bar/test/foo.gif 


=head1 SPECIAL BEHAVIOR

If the request-URI ends with '/', and a application type rule is 
available, then the module will always give the connection to the 
best matching application rule. 

=head1 CREATE A CDB 

1) install cdbmake
2) call this script with the rules as stdin or as first parameter 

#!/usr/bin/perl 

use bytes;
open(CDBMAKE,"|cdbmake /etc/perlbal/urlmap.cdb /etc/perlbal/urlmap.cdb.tmp " ) or die "Could not open cdbmake: $!";

while(<>) { 
        chop;
        my ($vhost,@s) = split(/,/);
        my $data = $vhost . ',' . join(',',@s);
        print CDBMAKE '+' . length($vhost) . ',' . length($data) . ':' . $vhost . '->' . $data . "\n";
}

print CDBMAKE "\n";
close CDBMAKE;

# end 


=head1 EXAMPLE RULES

test.org,/.*\.php,,~chi/public_html,file,application/php,
test.org,/,,~chi/public_html,file,,
foo.nl,/,,http://www.kapow.com/games/statetris/index.cgi?origpath=,redirect-uri,,
foo.nl,/,,http://www.evdw..nl/anything,frame-uri,,
foto.bar.com,/,,http://sanderandpeter.dsl.nl/insideafrika,redirect,,
traffel.bar.com,/,,~sander/public_html/afrikareis,fotoalbum,,
harharhar.br,/,,http://www.harharhar.nl/brasil,frame,,
agenda.stuff.nl,/.*\.php,,~tom/public_html/agenda,file,application/php5,


=head1 BUGS AND LIMITATIONS

There are no known bugs in this module.

Please report problems to the author or the 
Perlbal mailing list, http://groups.google.com/group/perlbal

Patches are always welcome.

=head1 AUTHORS


Paul Vogel 	 <paulv@bikkel.org>


=head1 LICENSE AND COPYRIGHT

Artistic/GPLv2, at your choosing.


